home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / listops.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  7.4 KB  |  360 lines
  1. /* ******************************************************************** */
  2. /* listops.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* further list operations                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: listops.c,v 1.5 1992/01/07 22:15:36 pab Exp $
  9.  *
  10.  * $Log: listops.c,v $
  11.  * Revision 1.5  1992/01/07  22:15:36  pab
  12.  * ncc compatable, plus backtrace
  13.  *
  14.  * Revision 1.4  1991/12/22  15:14:15  pab
  15.  * Xmas revision
  16.  *
  17.  * Revision 1.3  1991/09/22  19:14:35  pab
  18.  * Fixed obvious bugs
  19.  *
  20.  * Revision 1.2  1991/09/11  12:07:20  pab
  21.  * 11/9/91 First Alpha release of modified system
  22.  *
  23.  * Revision 1.1  1991/08/12  16:49:43  pab
  24.  * Initial revision
  25.  *
  26.  * Revision 1.4  1991/02/13  18:22:07  kjp
  27.  * Pass.
  28.  *
  29.  */
  30.  
  31. /*
  32.  * Change Log:
  33.  *   Version 1, March 1990 (Compiler rationalisation)
  34.  */
  35.  
  36. #include "defs.h"
  37. #include "structs.h"
  38. #include "funcalls.h"
  39.  
  40. #include "error.h"
  41. #include "global.h"
  42. #include "modboot.h"
  43. #include "symboot.h"
  44. #include "calls.h"
  45. #include "modules.h"
  46. #include "ngenerics.h"
  47.  
  48. LispObject flat_list_copy(LispObject *);
  49.  
  50. EUFUN_1( Fn_null, form)
  51. {
  52.   return (form==nil?lisptrue:nil);
  53. }
  54. EUFUN_CLOSE
  55.  
  56.                 /* Destructive append */
  57. EUFUN_2( Fn_nconc,  form1, form2)
  58. {
  59.   LispObject p = form1;
  60.   if (!is_cons(form1)) return(form2);
  61.   while (CDR(p)!=nil) p = CDR(p);
  62.   CDR(p) = form2;
  63.   return form1;
  64. }
  65. EUFUN_CLOSE
  66.  
  67. EUFUN_2( Fn_append,  l1, l2)
  68. {
  69.   LispObject endptr,walker,val;
  70.  
  71.   if (!is_cons(l1)) return(l2);
  72.  
  73.   /* reasonable append */
  74.   
  75.   val = EUCALL_2(Fn_cons,CAR(l1),nil);
  76.   STACK_TMP(val);
  77.   endptr = val;
  78.   walker = CDR(ARG_0(stackbase)/*l1*/);
  79.   while (is_cons(walker))
  80.     {
  81.       LispObject xx;
  82.       STACK_TMP(endptr);
  83.       STACK_TMP(CDR(walker));
  84.       xx = EUCALL_2(Fn_cons, CAR(walker), nil);
  85.       UNSTACK_TMP(walker);
  86.       UNSTACK_TMP(endptr);
  87.       CDR(endptr)=xx;
  88.       endptr=CDR(endptr);
  89.     }
  90.   CDR(endptr) = ARG_1(stackbase)/*l2*/;
  91.   UNSTACK_TMP(val);
  92.   return(val);
  93. }
  94. EUFUN_CLOSE
  95.  
  96.                 /* Simple predicate for NULL */
  97. EUFUN_1( Fn_lastpair, form)
  98. {
  99.   while (!is_cons(form))
  100.     form = CallError(stacktop,"Not a list in last-pair",form,CONTINUABLE);
  101.   while (CDR(form)!=nil) form = CDR(form);
  102.   return form;
  103. }
  104. EUFUN_CLOSE
  105.  
  106. EUFUN_1( Fn_nreverse, form)
  107. {
  108.   LispObject x=nil;
  109.   while (form!=nil) {
  110.     LispObject y = CDR(form);
  111.     CDR(form) = x;
  112.     x = form;
  113.     form = y;
  114.   }
  115.   return x;
  116. }
  117. EUFUN_CLOSE
  118.  
  119. EUFUN_3( Fn_assoc, obj, list, fn)
  120. {
  121.   while (list!=nil) {
  122.     LispObject xx;
  123.     EUCALLSET_3(xx,apply2,ARG_2(stackbase),ARG_0(stackbase),CAR(CAR(list)));
  124.     if (xx != nil)  {
  125.       list=ARG_1(stackbase);
  126.       return CAR(list);
  127.     }
  128.     list = ARG_1(stackbase);
  129.     list = CDR(list);
  130.     ARG_1(stackbase) = list;
  131.   }
  132.   return nil;
  133. }
  134. EUFUN_CLOSE
  135.  
  136. EUFUN_3( Fn_member, obj, list, fn)
  137. {
  138.   while (list!=nil) {
  139.     if (EUCALL_3(apply2,ARG_2(stackbase),ARG_0(stackbase),CAR(list)) != nil) {
  140.       return ARG_1(stackbase);
  141.     }
  142.     list = ARG_1(stackbase);
  143.     list = CDR(list);
  144.     ARG_1(stackbase) = list;
  145.   }
  146.   return nil;
  147. }
  148. EUFUN_CLOSE
  149.  
  150. EUFUN_2( Fn_memq,  obj, list)
  151. {
  152.   if (!is_cons(list) && list != nil)
  153.     CallError(stacktop,"memq: non-lists passed",list,NONCONTINUABLE);
  154.  
  155.   while (is_cons(list)) {
  156.     if (obj == CAR(list))
  157.       return(lisptrue);
  158.     else
  159.       list = CDR(list);
  160.   }
  161.   
  162.   return(nil);
  163. }
  164. EUFUN_CLOSE
  165.  
  166. /* ******************************************************************** */
  167. /*                            Lisp Mappers                              */
  168. /* ******************************************************************** */
  169.  
  170. static LispObject mapcar_apply_args(LispObject *stackbase, LispObject set)
  171. {
  172.   LispObject walker,res,ptr;
  173.   LispObject *stacktop=stackbase+1;
  174.  
  175.   ARG_0(stackbase)=nil;
  176.   res = nil; ptr = nil;
  177.  
  178.   walker = set;
  179.   while (is_cons(walker)) 
  180.     {
  181.       if (!is_cons(CAR(walker))) 
  182.     return(nil);
  183.  
  184.       STACK_TMP(CDR(walker));
  185.       if (ptr == nil)
  186.     {
  187.       EUCALLSET_2(res, Fn_cons,CAR(CAR(walker)),nil);
  188.       ARG_0(stackbase)=res;
  189.       ptr = res;
  190.     }
  191.       else
  192.     {
  193.       LispObject xx;
  194.       STACK_TMP(ptr);
  195.       EUCALLSET_2(xx, Fn_cons, CAR(CAR(walker)),nil);
  196.       UNSTACK_TMP(ptr);
  197.       CDR(ptr) = xx;
  198.       ptr = CDR(ptr);
  199.     }
  200.       UNSTACK_TMP(walker);
  201.     }
  202.   res=ARG_0(stackbase);
  203.   return(res);
  204. }
  205.  
  206. static LispObject mapcar_advance_lists(LispObject set)
  207. { 
  208.   LispObject walker = set;
  209.  
  210.   while (is_cons(walker)) {
  211.     CAR(walker) = CDR(CAR(walker));
  212.     walker = CDR(walker);
  213.   }
  214.   
  215.   return(set);
  216. }
  217.  
  218. EUFUN_3( Fn_mapcar, fn, l1, lists)
  219. {
  220.   LispObject flat_list_copy(LispObject *);
  221.   
  222.   if (!is_cons(l1) && l1 != nil)
  223.     CallError(stacktop,"mapcar: not a list",l1,NONCONTINUABLE);
  224.  
  225.   ARG_3(stackbase)=nil;
  226.   stacktop++;
  227.  
  228.   {
  229.     LispObject set,args;
  230.     LispObject res,ptr,val;
  231.     
  232.     /* More general... */
  233.  
  234.     EUCALLSET_1(set, flat_list_copy, lists);
  235.     EUCALLSET_2(set, Fn_cons,ARG_1(stackbase),set);
  236.  
  237.     res = nil; ptr = nil;
  238.       
  239.     while (TRUE) 
  240.       {
  241.  
  242.     /* Construct args to apply... */
  243.       
  244.     STACK_TMP(set);    
  245.     STACK_TMP(ptr);
  246.     if ((args = mapcar_apply_args(stacktop,set)) == nil) 
  247.       {    
  248.         res=ARG_3(stackbase);
  249.         return(res);
  250.       }
  251.     UNSTACK_TMP(ptr);
  252.     STACK_TMP(ptr);
  253.     EUCALLSET_2(val,module_mv_apply_1,ARG_0(stackbase),args);
  254.     UNSTACK_TMP(ptr);
  255.       
  256.     if (ptr == nil)
  257.       {
  258.         EUCALLSET_2(res, Fn_cons,val,nil);
  259.         ARG_3(stackbase)=res;
  260.         ptr = res;
  261.       }
  262.     else 
  263.       {
  264.         LispObject xx;
  265.         STACK_TMP(ptr);
  266.         EUCALLSET_2(xx, Fn_cons, val,nil);
  267.         UNSTACK_TMP(ptr);
  268.         CDR(ptr) = xx;
  269.         ptr = CDR(ptr);
  270.       }
  271.     UNSTACK_TMP(set);
  272.     mapcar_advance_lists(set);
  273.       }
  274.   }
  275.  
  276.   return(nil);
  277. }
  278. EUFUN_CLOSE
  279.  
  280. EUFUN_3( Fn_mapc, fn, l1, lists)
  281. {
  282.  
  283.   if (!is_cons(l1) && l1 != nil)
  284.     CallError(stacktop,"mapc: not a list",l1,NONCONTINUABLE);
  285.  
  286.   if (FALSE) {
  287.     ;
  288.   }
  289.   else {
  290.     LispObject set,args;
  291.     
  292.     /* More general... */
  293.  
  294.     EUCALLSET_1(set,flat_list_copy,lists);
  295.     EUCALLSET_2(set, Fn_cons,ARG_1(stackbase),set);
  296.  
  297.     while (TRUE) {
  298.       LispObject dummy;
  299.  
  300.       /* Construct args to apply... */
  301.  
  302.       STACK_TMP(set);
  303.       if ((args = mapcar_apply_args(stacktop,set)) == nil) {
  304.     return(nil);
  305.       }
  306.       UNSTACK_TMP(set);
  307.  
  308.       STACK_TMP(set);
  309.       EUCALL_2(module_mv_apply_1,ARG_0(stackbase),args);
  310.       UNSTACK_TMP(set);
  311.       mapcar_advance_lists(set);
  312.     }
  313.   }
  314.  
  315.   return(nil);
  316. }
  317. EUFUN_CLOSE
  318.  
  319. EUFUN_1( flat_list_copy, list)
  320. {
  321.   LispObject xx;
  322.   if (!is_cons(list)) return(nil);
  323.   EUCALLSET_1(xx, flat_list_copy, CDR(list));
  324.   return(EUCALL_2(Fn_cons, CAR(ARG_0(stackbase)),xx));
  325. }
  326. EUFUN_CLOSE
  327.   
  328. /*
  329.  
  330.  * Initialise the module...
  331.  
  332.  */
  333.  
  334. #define LISTOPS_ENTRIES 11
  335. MODULE Module_listops;
  336. LispObject Module_listops_values[LISTOPS_ENTRIES];
  337.  
  338. void initialise_listops(LispObject *stacktop)
  339. {
  340.   open_module(stacktop,
  341.           &Module_listops,
  342.           Module_listops_values,
  343.           "list-operators",
  344.           LISTOPS_ENTRIES);
  345.  
  346.   (void) make_module_function(stacktop,"memq",Fn_memq,2);
  347.   (void) make_module_function(stacktop,"append",Fn_append,2);
  348.   (void) make_module_function(stacktop,"copy-list",flat_list_copy,1);
  349.   (void) make_module_function(stacktop,"null",Fn_null,1);
  350.   (void) make_module_function(stacktop,"nconc",Fn_nconc,2);
  351.   (void) make_module_function(stacktop,"last-pair",Fn_lastpair,1);
  352.   (void) make_module_function(stacktop,"nreverse",Fn_nreverse,1);
  353.   (void) make_module_function(stacktop,"assoc",Fn_assoc,3);
  354.   (void) make_module_function(stacktop,"member",Fn_member,3);
  355.   (void) make_module_function(stacktop,"mapcar",Fn_mapcar,-3);
  356.   (void) make_module_function(stacktop,"mapc",Fn_mapc,-3);
  357.  
  358.   close_module();
  359. }
  360.